From da610806f103bbfeaa36f419ae4f332e3e6d4a75 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 5 Jan 2017 19:23:35 -0800
Subject: [PATCH] *mplement object-tagger.

---
 src/runtime/runtime.pkg |  1 +
 src/runtime/tagging.scm | 10 +++++++++-
 2 files changed, 10 insertions(+), 1 deletion(-)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 467152d5a..9d4f4b4a1 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3597,6 +3597,7 @@ USA.
   (parent (runtime))
   (export ()
 	  guarantee-tagged-object
+	  object-tagger
 	  set-tagged-object-unparser-method!
 	  tag-object
 	  tagged-object-datum
diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index 7efcd7bd1..fec5f84da 100644
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -35,12 +35,20 @@ USA.
 (define (tagged-object? object)
   (fix:= (object-type object) tagged-object-type))
 
+(define (object-tagger predicate)
+  (let ((tag (predicate->tag predicate)))
+    (lambda (datum)
+      (make-tagged-object tag datum))))
+
 (define (tag-object predicate datum)
-  (system-pair-cons tagged-object-type (predicate->tag predicate) datum))
+  (make-tagged-object (predicate->tag predicate) datum))
 
 (define (tagged-object-predicate object)
   (tag->predicate (tagged-object-tag object)))
 
+(define-integrable (make-tagged-object tag datum)
+  (system-pair-cons tagged-object-type tag datum))
+
 (define (tagged-object-tag object)
   (guarantee tagged-object? object 'tagged-object-tag)
   (system-pair-car object))
-- 
2.25.1