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

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 5f3bf2e1a937fd258ee338cff208285e1f1c528e..c4d8a5a2450577fd478945ab9efa764fae273138 100644 (file)
--- 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))))