From bf5113c37b284a38a38d6ba18f7fd8a6ddba6cf4 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 13 May 2018 20:02:16 -0700
Subject: [PATCH] Fix bug: earlier rewrite of printer broke pp.

---
 src/runtime/pp.scm      |  4 +---
 src/runtime/printer.scm | 10 ++++++++++
 src/runtime/runtime.pkg |  3 ++-
 3 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 8262b28c3..a654e6857 100644
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -787,9 +787,7 @@ USA.
 (define (walk-custom object list-depth)
   (call-with-output-string
     (lambda (port)
-      (parameterize* (list (cons param:printer-list-depth-limit list-depth))
-	(lambda ()
-	  (write object port))))))
+      (print-for-pp object port list-depth))))
 
 (define (walk-pair pair list-depth)
   (if (let ((limit (get-param:printer-list-depth-limit)))
diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 6e119dc78..2728cf3f3 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -215,6 +215,16 @@ USA.
 		      (get-param:printer-list-breadth-limit)
 		      (get-param:printer-list-depth-limit)))))
 
+(define (print-for-pp object port list-depth)
+  (print-object object
+		(make-context port
+			      'normal
+			      list-depth
+			      #f
+			      (make-labeling-procedure object 'circularity)
+			      (get-param:printer-list-breadth-limit)
+			      (get-param:printer-list-depth-limit))))
+
 (define (make-labeling-procedure object label-mode)
   (let ((shared-objects
 	 (case label-mode
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 987d93416..327546925 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4867,7 +4867,8 @@ USA.
   (export (runtime pretty-printer)
 	  get-param:printer-list-breadth-limit
 	  get-param:printer-list-depth-limit
-	  prefix-pair?)
+	  prefix-pair?
+	  print-for-pp)
   (export (runtime swank)
 	  user-object-type))
 
-- 
2.25.1