From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 13 May 2018 05:32:36 +0000 (-0700)
Subject: Assume that named vector/list unparsers are in fact print methods.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~58
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eacd95623315f04303a6fa92c676d9074b27d7fc;p=mit-scheme.git

Assume that named vector/list unparsers are in fact print methods.
---

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 5f3bf2e1a..c4d8a5a24 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -301,15 +301,18 @@ USA.
 			  (print-object part context*))
 			(standard-print-method-parts print-method object)))))
 	  (print-method
-	   (parameterize* (list (cons initial-context context))
-	     (lambda ()
-	       (print-method object (context-port context)))))
+	   (call-print-method print-method object context))
 	  (else
 	   ((vector-ref dispatch-table
 			((ucode-primitive primitive-object-type 1) object))
 	    object
 	    context)))))
 
+(define (call-print-method print-method object context)
+  (parameterize* (list (cons initial-context context))
+    (lambda ()
+      (print-method object (context-port context)))))
+
 (define (get-print-method-parts object)
   (let ((print-method (get-print-method object)))
     (and (standard-print-method? print-method)
@@ -616,7 +619,7 @@ USA.
 (define (print-vector vector context)
   (let ((printer (named-vector-with-unparser? vector)))
     (if printer
-	(printer context vector)
+	(call-print-method printer vector context)
 	(limit-print-depth context
 	  (lambda (context*)
 	    (let ((end (vector-length vector)))
@@ -688,7 +691,7 @@ USA.
         ((and (get-param:print-streams?) (stream-pair? pair))
          (print-stream-pair pair context))
 	((named-list-with-unparser? pair)
-	 => (lambda (printer) (printer context pair)))
+	 => (lambda (printer) (call-print-method printer pair context)))
         (else
          (print-list pair context))))