Teach pp to respect custom print methods for tagged vectors.

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index a14c047935647555cf15c1e44f72bd0ab0c65dad..403191b498fec3def5137cf2fbadd8db84dd5442 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -730,7 +730,9 @@ USA.
 
 (define (numerical-walk object list-depth)
   (define (numerical-walk-no-auto-highlight object list-depth)
-    (cond ((and (pair? object)
+    (cond ((get-print-method object)
+          (walk-custom object list-depth))
+         ((and (pair? object)
                (not (named-list? object)))
           (let ((prefix (prefix-pair? object)))
             (if prefix

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 934c6fe6d26c494aec7554897f9421db08fbdd09..76c0b85a055153ff58c2308afd7ca6e9b57ca056 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4986,7 +4986,8 @@ USA.
          get-param:printer-list-breadth-limit
          get-param:printer-list-depth-limit
          prefix-pair?
-         print-for-pp)
+         print-for-pp
+         get-print-method)
   (export (runtime swank)
          user-object-type))
 

diff --git a/tests/runtime/test-pp.scm b/tests/runtime/test-pp.scm
index 6ccd930ad5261becbe6ff1700eb90ad38b5e44ef..7921c462c9a59eb1a6c2932455c460bfee503d57 100644 (file)
--- a/tests/runtime/test-pp.scm
+++ b/tests/runtime/test-pp.scm
@@ -108,20 +108,18 @@ USA.
 
 (define-test 'custom
   (lambda ()
-    (expect-failure
-     (lambda ()
-       (let ((tag (cons 0 0)))
-         (define (loser? object)
-           (and (vector? object)
-                (<= 1 (vector-length object))
-                (eq? tag (vector-ref object 0))))
-         (register-predicate! loser? 'loser? '<= vector?)
-         (define-print-method loser?
-           (standard-print-method
-            (lambda (object) object "LOSER")
-            (lambda (object) object '(42))))
-         (let* ((loser (make-vector 1000 tag))
-                (hash (number->string (hash-object loser))))
-           (assert-equal
-            (call-with-output-string (lambda (port) (pp loser port)))
-            (string-append "#[LOSER " hash " 42]\n"))))))))
+    (let ((tag (cons 0 0)))
+      (define (loser? object)
+        (and (vector? object)
+             (<= 1 (vector-length object))
+             (eq? tag (vector-ref object 0))))
+      (register-predicate! loser? 'loser? '<= vector?)
+      (define-print-method loser?
+        (standard-print-method
+         (lambda (object) object "LOSER")
+         (lambda (object) object '(42))))
+      (let* ((loser (make-vector 1000 tag))
+             (hash (number->string (hash-object loser))))
+        (assert-equal
+         (call-with-output-string (lambda (port) (pp loser port)))
+         (string-append "#[LOSER " hash " 42]\n"))))))