From 748e3ef7cc2494428cfa04f1ce0a7375d8543429 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 24 Sep 2014 06:56:24 -0500
Subject: [PATCH] add stronger to syntax/c

---
 .../tests/racket/contract/stronger.rkt        |  3 +++
 .../collects/racket/contract/private/misc.rkt | 24 +++++++++++++------
 2 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
index c01253f5a7..b46a31f849 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
@@ -230,6 +230,9 @@
   (ctest #t contract-stronger? (promise/c (<=/c 2)) (promise/c (<=/c 3)))
   (ctest #f contract-stronger? (promise/c (<=/c 3)) (promise/c (<=/c 2)))
   
+  (ctest #t contract-stronger? (syntax/c (<=/c 3)) (syntax/c (<=/c 4)))
+  (ctest #f contract-stronger? (syntax/c (<=/c 4)) (syntax/c (<=/c 3)))
+  
   (ctest #t contract-stronger?
          (class/c (m (-> any/c (<=/c 3))))
          (class/c (m (-> any/c (<=/c 4)))))
diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
index 5213ae422f..f2f0a225da 100644
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@@ -1037,14 +1037,24 @@
    #:val-first-projection list/c-chaperone/other-val-first-projection
    #:list-contract? (λ (c) #t)))
 
+(struct syntax-ctc (ctc)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name (λ (ctc) (build-compound-type-name 'syntax/c (syntax-ctc-ctc ctc)))
+   #:stronger (λ (this that)
+                (and (syntax-ctc? that)
+                     (contract-stronger? (syntax-ctc-ctc this)
+                                         (syntax-ctc-ctc that))))
+   #:first-order (λ (ctc) 
+                   (define ? (flat-contract-predicate (syntax-ctc-ctc ctc)))
+                   (λ (v)
+                     (and (syntax? v)
+                          (? (syntax-e v)))))))
+
 (define/subexpression-pos-prop (syntax/c ctc-in)
-  (let ([ctc (coerce-flat-contract 'syntax/c ctc-in)])
-    (flat-named-contract
-     (build-compound-type-name 'syntax/c ctc)
-     (let ([pred (flat-contract-predicate ctc)])
-       (λ (val)
-         (and (syntax? val)
-              (pred (syntax-e val))))))))
+  (define ctc (coerce-flat-contract 'syntax/c ctc-in))
+  (syntax-ctc ctc))
 
 (define/subexpression-pos-prop promise/c
   (λ (ctc-in)