define-singleton.rkt

#lang racket

(require (for-syntax racket/syntax
                     threading)
         racket/contract
         syntax/parse/define)

(define/contract (make-singleton name)
  (-> symbol? any/c)
  (struct singleton ()
    #:reflection-name name
    ; Never print constructor-style, even if the inspector is stronger.
    #:property prop:custom-write
    (let ([str (string-append "#<" (symbol->string name) ">")])
      (λ (self out mode) (write-string str out))))
  (singleton))

(define-simple-macro (define-singleton name:id)
  #:with name? (format-id #'name "~a?" #'name)
  #:do [(define name-len (string-length (symbol->string (syntax-e #'name))))]
  #:with name?+sub-range-binders (syntax-property #'name? 'sub-range-binders
                                                  (list (vector (syntax-local-introduce #'name?)
                                                                0 name-len 0.5 0.5
                                                                (syntax-local-introduce #'name)
                                                                0 name-len 0.5 0.5)))
  (begin
    (define name (make-singleton 'name))
    (define (name?+sub-range-binders v) (eq? v name))))

(define-simple-macro (define-singletons name:id ...+)
  (begin (define-singleton name) ...))

(define-singleton foo)