From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 2 Dec 2018 03:32:42 +0000 (+0000)
Subject: Teach pp to respect custom print methods for tagged vectors.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~53
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c1c65b0b455d94e9932d2a01fd588d58e12841b5;p=mit-scheme.git

Teach pp to respect custom print methods for tagged vectors.
---

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index a14c04793..403191b49 100644
--- 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 934c6fe6d..76c0b85a0 100644
--- 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 6ccd930ad..7921c462c 100644
--- 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"))))))