From 4c6d09dab929af49b419a95471e01184759eed79 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 27 Feb 2016 13:29:17 -0800
Subject: [PATCH] Implement make-parameter*.

---
 src/runtime/dynamic.scm | 20 ++++++++++++--------
 src/runtime/runtime.pkg |  1 +
 2 files changed, 13 insertions(+), 8 deletions(-)

diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm
index bf646a681..35db0bd68 100644
--- a/src/runtime/dynamic.scm
+++ b/src/runtime/dynamic.scm
@@ -53,18 +53,22 @@ USA.
 
 (define-guarantee parameter "parameter")
 
-(define (make-parameter init #!optional converter)
-  (let* ((converter
-	  (if (default-object? converter)
-	      (lambda (x) x)
-	      converter))
-	 (metadata (cons converter (converter init)))
+(define (make-parameter initial-value #!optional write-converter)
+  (let ((noop (lambda (x) x)))
+    (make-parameter* initial-value
+		     noop
+		     (if (default-object? write-converter)
+			 noop
+			 write-converter))))
+
+(define (make-parameter* initial-value read-converter write-converter)
+  (let* ((metadata (cons write-converter (write-converter initial-value)))
 	 (parameter
 	  (lambda (#!optional new-value)
 	    (let ((p (or (assq metadata bindings) metadata)))
 	      (if (default-object? new-value)
-		  (cdr p)
-		  (set-cdr! p (converter new-value)))))))
+		  (read-converter (cdr p))
+		  (set-cdr! p (write-converter new-value)))))))
     (set-parameter-metadata! parameter metadata)
     parameter))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e50101e45..431bf3539 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4581,6 +4581,7 @@ USA.
   (export ()
 	  parameter?
 	  make-parameter
+	  make-parameter*
 	  parameterize*)
   (initialization (initialize-package!)))
 
-- 
2.25.1